Population Data Management Lab

Studbook Overview

Let’s create a graphical table to summarize our studbook data.

studbook.tbl <- studbook %>% studbook_react(., studbook.cols(.), groupBy = "Status")
studbook.tbl

Summarize Demographic Trends

Let’s look at the basic population size over time to begin quantifying growth rate and assessing overall population viability.

raw.counts      <- census(timeline, studbook, "years")

population.plot <- plot_census(raw.counts, colors, "Pygmy Loris Population Trends 1966-2025")
population.plot

Life Table Calculations

Now we will use annual birth counts to follow the standard method for computing a normalized rate of growth over the past 5 years compared to all years.

lifeTab      <- cohort_lifeTab(timeline, studbook, 1985, 2024, 5, 22)

And then we will plot trends in this growth rate based on birth year.

lambda.plot  <- plot_lambda(lifeTab, colors, "Population Growth Rates by Cohort")
lambda.plot

Construct Pedigree

Now we will use a package called pedtools to create our pedigree objects based on the studbook data. We will use the pedigree object to generate all genetic stats and projections.

pedig <- ped(
  id     = studbook$ID,
  fid    = studbook$Sire,
  mid    = studbook$Dam,
  sex    = studbook$sex_ped
) %>% discard(., \(x) pedtools::pedsize(x) <= 1)

The object pedig most likely contains a list of multiple pedigree objects, as any founders or lineages not represented in the current living population will form discrete, disconnected trees. There also will probably be several “singletons” which are founders without any connections to the living population. That is why the code above also included a line to thin out your dataset by ignoring the founders that never reproduced.

Pedigree Plot

Now we will take a look at your data in the form of the traditional pedigree structures we covered in class. The code below will prepare some formatting variables to assign color-coding before plotting the pedigree(s) you already created.

ped_list_plots <- plot_ped_series(pedig, colors, studbook)
ped_list_plots
$`_comp5`

$`_comp11`

$`_comp13`

$`_comp23`

$`_comp26`

Most of you probably still have multiple plots, one of which looks much more complicated than the others. We can thin our dataset out even more by filtering for just those individuals still represented in the living population. That means we want to set aside any of the lineages where the descendants are no longer related to any living individuals through surviving siblings, offspring, nieces, nephews, etc. In most cases, that will leave us with one large and complicated pedigree representing all the contemporary diversity in our population. You should inspect the plots about and decide which one to carry forward for your analysis, based on this concept. Once you have done so, update the "_comp5" in the code chunk below with the title you see for your chosen plot. You will need to click “run code” before proceeding. Note: you can come back and run the code chunk again any time with a different name inserted, and all future steps will update based on that selection.

includes_living <- c("_comp5")

ped.living  <- keep_at(pedig, includes_living)
ped.living  <- ped.living[[1]]
famid(ped.living) <- "Current"
ped_living_plot <- plot_pedigree(ped.living, 
              "Pedigree of Living Population", 
              studbook,
              set_ped_fills(ped.living, colors, studbook))

Click to see pedigree

Click to download pedigree

Better Pedigree Graphics

I don’t love the pedtools graphics system and lack of customization/interactivity, so if we want to look more closely at the details of relationships and clustering across a complex pedigree, we can transfer the data produced by pedtools into some other visualization packages. In this case, we will use visNetwork Run the chunk below to render two different visualizations.

ped.net  <- ped_network(ped.living, colors, studbook)
ped.vert <- ped.net %>% visHierarchicalLayout(direction = "UD", shakeTowards = "roots")

Hierarchical Layout

First, you will generate a hierarchical plot that resembles the traditional pedigree structure above. Note that the horizontal-bar icons represent each mother-father pair with one or more shared offspring. The dotted lines lead from each parent to the icon representing their parental unit, with color-coding and labels corresponding to the institution where the pair produced their shared offspring. The solid lines coming from each bar-icon connect the parental unit to the offspring that would be full-siblings.

Note: these plots depend on some more memory-intensive javascript code, so you will experience more of a delay than usual before the image loads. If you see a blank plotting area at first, just wait a few minutes for the image to appear.

Click to see output

Network Layout

Second, you will view the same plot as a network instead of a hierarchy. This gives a clearer representation of the clustering around particularly successful mated pairs and institutions.

Note: this one takes even longer to load than the previous plot.

Click to see output

Generate Detailed Pedigree Statistics

Next, we will generate some of the descriptive statistics that we can use to assess the long-term viability of our populations and make some breeding recommendations.

Founders Represented

We will need information about founders still represented in the living population, which we can summarize with the code below.

founder.summary <- founder_summary(pedig, ped.living, studbook)
founder.vis     <- founder.summary %>% studbook_react(., cols = founder.cols(.))

Click to see output

Contemporary Population

Now we will generate some additional stats to give us a similar glimpse of the historical lineage, current representation, and breeding success of our living population.

Inbreeding Coefficients

We will use the pedigree object to calculate an inbreeding coefficient for each individual in the living population.

Recall the definition of inbreeding coefficients…<>

The autosomal inbreeding coefficient of a pedigree member is defined as the probability that, at a random autosomal locus, the two alleles carried by the member are identical by descent, relative to the pedigree.

It follows from the definition that the inbreeding coefficient of a non-founder equals the kinship coefficient of the parents.

<>

inbred.ped <- inbreeding(ped.living) %>% enframe(name = "ID", value = "inbred")
inbred.tbl <- datatable(inbred.ped)

Click to see output

Kinship Coefficients

This gives us some information about each individual’s genetic history, especially their potential to contribute more/less genetic diversity to the next generation, but what does that mean when they are matched to an individual with a higher/lower inbreeding coefficient? When we match individuals, two individuals with moderate inbreeding coefficients but little shared ancestory might still have a positive or neutral impact on the population’s long-term viability. That is why we will also calculate a pairwise metric to score each potential match - the kinship coefficient.

Recall the definition of kinship coefficients…<>

For two (possibly equal) members A, B of a pedigree, their autosomal (resp. X-chromosomal) kinship coefficient is defined as the probability that a random allele from A and a random allele from B, sampled at the same autosomal (resp. X-chromosomal) locus, are identical by descent, relative to the pedigree.

<>

kinship.ped    <- ribd::kinship(ped.living)
living.ped     <- intersect(living, rownames(kinship.ped))
living.kinship <- kinship.ped[living.ped, living.ped]
kinship.mat    <- datatable(living.kinship)

The code above created a matrix that we will use in other code chunks below.

Click to see matrix preview

Other Summary Stats

We can also extract some basic counts from our pedigree for each individual before we create some visual summaries below.

living.summary <- family_history(ped.living, studbook) %>% 
  studbook_react(., 
                 cols         = living.cols(.), 
                 columnGroups = list(kin.group())
                 )

Click to see output

Overall Relatedness and Kinship

Now we will use some of the demographic stats we already computed to begin modeling our expected patterns in relatedness and inbreeding across the living population. First, we need to create a matrix representing every living pair’s kinship coefficient. We will return to these pairwise relationships soon, but for now we will use it to compute our population-level statistics.

Visualize Summary Table

Now you can view a summary of the statistics we just calculated and compare them to the summaries provided in the Pygmy Loris BTP. You will refer back to this table and the figures compiled so far to write your own version of a summary (1-2 paragraphs max).

kinship.summary <- kinship_summary(pedig, ped.living, studbook) %>%
  mutate(across(where(is.numeric), ~round(., digits = 3))) %>%
  reactable(theme = minty(font_size = 17), columns = kin.cols())

Click to see output

Pairwise Summary Stats

coeff_living <- coeffTable(ped.living, coeff = c("f", "phi", "deg", "kappa")) %>%
  filter(id1 %in% living(studbook) & id2 %in% living(studbook)) %>%
  mutate(across(where(is.numeric), ~ round(., digits = 3))) %>%
  select(id1, 
         id2, 
         degree = deg, 
         inbred = f2, 
         phi, 
         kappa0 = k0, 
         kappa1 = k1, 
         kappa2 = k2)
example <- basicRelationships %>%
  mutate(across(where(is.numeric), ~ round(., digits = 3))) %>%
  select(label, relationship, phi, starts_with("kappa")) %>% datatable()
coeff.tbl <- datatable(coeff_living)

Click to see demo table with expected values

Click to see our results

Kinship Coefficients

It is much easier to visualize pairwise relationships as matrices or multidimensional plots. Let’s create some graphical visualizations to interpret these stats. The code below will produce a basic visualization of the overall patterns in relatedness between all living individuals in the current population. Each cell will be colored by the pairwise kinship coefficients we computed above.

kin.plot <- matrix.heatmap(living.kinship, 
                           "Kinship Across Living Population", 
                           "Kinship Coefficients")

Click to see output

Matched Pairs

Finally, we want to look closer at potential breeding pairs to do some match-making, so let’s generate some more pedigree statistics per individual and then visualize a plot of breeding pairs.

Kinship Coefficients

kinship_btp  <- subset_matrix_living(living.kinship, studbook)
btp.plot     <- matrix.heatmap(kinship_btp, "Kinship Values for Potential Mate Pairs", "Kinship Vals")

Click to see output

Select & Visualize Match

Once you choose some potential pairs, you should plug their ID’s into the code chunks below. You need to click “run code” to log your entry for selected pair ids before proceeding. This will give you a few more graphics to inspect their relationship. You can easily swap out different IDs and re-run the code chunks to see those revised results until you find the pairs you are happy with.

male   <- c("2652") # Replace the number here with the ID number of your male of interest.
female <- c("2677") # Replace the number here with the ID number of your female of interest.

pair   <- c(male, female)

IBD and Kappa Coefficients

Now we are going to print something called a Kappa Triangle. This is a way to visualize the most probable identity by descent (IBD) for this pair in a 2-dimensional space.

kappa.pair <- coeff_living %>%
  filter(xor((id1 == male   & id2 == female), 
             (id1 == female & id2 == male))) %>%
  select(id1, id2, kappa0, kappa1, kappa2)
kappa.tbl  <- datatable(kappa.pair)
kappa.tri <- showInTriangle(kappa.pair, plotType = "plotly")

Click to see result

Click to see plot

The red X mark represents the relationship between your hypothetical pair, while the letters in the graphic above are reference points for where different relationships would fall in that space. The summary table below contains a key for those abbreviations (and their associated values plotted above).

For help interpreting the abbreviations in the graphic

Annotated Subplots for Match

Now we can reconstruct our network visualizations with clearer annotations to focus on our proposed pair.

Recall that these plots can be slower to load, but they should be quicker now that we are only working with a subplot.

Also, note that the subtitle of these plots now contains a printed summary produced by the verbalise package that is part of pedsuite.

pair.net  <- subset_network_btp(ped.living, colors, pair, studbook)
pair.vert <- pair.net %>% visHierarchicalLayout(direction = "UD", shakeTowards = "roots")

Click to see graphic

Click to see graphic

Make your Plan and Report

Now you should use all the information provided to match at least one breeding pair for your new exhibit and add a paragraph in which you explain this choice and plan.

• Run each chunk below to render a plot or table created above.
• Read the excerpt from an example BTP and write your own version of a reflection on the results shown in that figure/table.
  • Yours does not need to be as precise or detailed as many of the examples provided. Just use the text to guide one or two sentences about each item.
• Once you have answered each of these questions, you should click the Knit button at the top of this panel and wait for R Studio to convert your document into an html report.
  • This is your group’s finalized Breeding and Transfer Plan.
  • You will load your html file into the assignment submission portal on canvas.
• Store the image files created in a location where you can access them later for your online portfolio.
  • Your working directory will contain a series of files ending in .html, .png, or .csv. You may find any of these useful later.
  • Note that to view the html files, you should double click the file to open it in an internet browser.

Demography

Examples

The Prosimian TAG has set a target population size of 55 animals in the Pygmy Slow Loris SSP population. The managed population has been increasing (λ = 0.96) historically, and has retained 92.39% of its founding gene diversity.

This SSP species first appeared in AZA facilities in 1968 when a single male was confiscated and transferred to the Honolulu Zoo. From 1968 – 1986, the population size remained low, never exceeding four individuals, and the Honolulu Zoo remained the only holding institution. The current SSP population was founded in 1987 when the San Diego Zoo, Duke Lemur Center, and Cincinnati Zoo imported 29 individuals from Sweden. The first recorded births occurred in 1988 at all three facilities that worked to import animals. The population steadily grew to a peak of 76 individuals by 2011 (Figure 1). This growth can largely be attributed to successful breeding and secondly to a small number of continued imports. Since 2012, the population has experienced a notable decline in size primarily due to insufficient reproduction. The reasons for this low, inconsistent reproduction in recent years are currently unclear, but may be associated with husbandry, particularly diet. However, the population has shown growth over the last five years again and there are enough births to offset deaths in the population.

Results

Summary Table - Founders

Plot - Population Growth

Summary Table - Kinship Metrics

Summary

Add your text here.

Genetics

Examples

Genetic values are calculated after incorporating pedigree assumptions and removing excluded individuals. Analysis of the studbook indicates that this SSP is descended from 30 founders with no potential founders remaining (Figure 3, Table 2). The gene diversity of the population is 92%. Based on current founder representations, gene diversity is equivalent to that found in approximately six founders. The current mean kinship in the population is 0.0799; first-cousins have a kinship of 0.0625, which means that the average relationship in the population is slightly closer than that of noninbred first-cousins.

Population management theory suggests genetic management should strive to maintain thresholds for tolerance of gene diversity loss. The standard goal is 90% gene diversity retention for 100 years. Decreases in gene diversity below 90% of that in the founding population have been associated with increasingly compromised reproduction by, among other factors, lower birth/hatch weights, smaller litter/clutch sizes, and greater neonatal mortality in some species.

Based on current population parameters, gene diversity is projected to decline to 66% over the next 100 years if the current population grows to the recommended target size of 55 (Table 3, Scenario a). The most effective ways this population can maintain more gene diversity are to have an increasing growth rate (vs. stable) and a larger long-term population size. The effective population size is high and is helping to maintain gene diversity in this population.

Results

Basic Plot

Pedigree Network

Kinship Heatmap - Potential Pairs

Summary

Add your text here.

Recommendations

Examples

NY BRONX
Bronx Zoo/Wildlife Conservation Society

SB ID	Local ID	Sex	Age	Disposition	Location	Breeding	With
2623	M14052	M	14	HOLD	NY BRONX	BREED WITH	2640
2640	M14053	F	12	HOLD	NY BRONX	BREED WITH	2623
2682	M19007	M	7	RECEIVE FROM	BLOOMINGT	BREED WITH	2708
2708	116283	F	4	RECEIVE FROM	NZP-WASH	BREED WITH	2682

NZP-WASH
Smithsonian National Zoological Park

SB ID	Local ID	Sex	Age	Disposition	Location	Breeding	With
2708	116283	4	14	SEND TO	NY BRONX	BREED WITH	2682
2715	116282	3	12	HOLD	NZP-WASH	DO NOT BREED
2735	116461	0	7	HOLD	NZP-WASH	DO NOT BREED
2736	116462	0	4	HOLD	NZP-WASH	DO NOT BREED

OMAHA
Omaha’s Henry Doorly Zoo

SB ID	Local ID	Sex	Age	Disposition	Location	Breeding	With
2652	24485	M	11	HOLD	OMAHA	BREED WITH	2677
2677	24709	F	7	HOLD	OMAHA	BREED WITH	2652

Results

Kappa Triangle

Shared Pedigree Ancestry

Summary Table of Current Population

Summary

Note: For your summary you should write a few sentences explaining the choice you made. You may use a table format like this, a bulleted list, or a paragraph to present your proposed breeding pair(s).

Add your text here.